home *** CD-ROM | disk | FTP | other *** search
VERSION 5.00 Begin VB.UserControl axDataButton AutoRedraw = -1 'True CanGetFocus = 0 'False ClientHeight = 435 ClientLeft = 0 ClientTop = 0 ClientWidth = 435 ScaleHeight = 29 ScaleMode = 3 'Pixel ScaleWidth = 29 ToolboxBitmap = "axButton.ctx":0000 Attribute VB_Name = "axDataButton" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes" '***************************************************************** ' axButton CONTROL ' This code and control is absolutely freeware! ' You have a royalty-free right to use, modify, reproduce and distribute ' the source code and control (and/or any modified version) in any way ' you find useful, provided that you agree that the authors have no warranty, ' obligations or liability for any code distributed in this project group. ' Copyright 1998 by Geoff Glaze ' (Some parts borrowed from Microsoft) ' If you make any improvements, the author would appreciate ' a copy of the improved source. If you include with any distribution, ' the author would appreciate notification. ' Send comments and updates to : gglaze@transtecinc.com ' My web page (coming soon) will be : www.cs.utexas.edu/users/gglaze '***************************************************************** Option Explicit Dim HaveCapture As Boolean Dim PaintedUp As Boolean Dim IsDown As Boolean Dim IsUp As Boolean Dim Inside As Boolean Dim ButtonVisible As Boolean 'Private mbClearURLOnly As Boolean 'Private mbClearPictureOnly As Boolean 'Private mbToolTipNotInExtender As Boolean 'Private moDrawTool As clsDrawPictures Private mbGotFocus As Boolean Private mbMouseOver As Boolean Private miCurrentState As Integer Private mWndProcNext As Long 'The address entry point for the subclassed window Private mHWndSubClassed As Long 'hWnd of the subclassed window Private mbLeftMouseDown As Boolean Private mbLeftWasDown As Boolean Private mudtButtonRect As RECT Private mudtPictureRect As RECT Private mudtPicturePoint As POINTAPI Private mbPropertiesLoaded As Boolean Private mbEnterOnce As Boolean Private mbMouseDownFired As Boolean Private mlhHalftonePal As Long Private hUpDownDitherBrush As Long Private UpDownButtonFace As Long 'Class level variables Private msToolTipBuffer As String 'Tool tip text; This string must have 'module or global level scope, because 'a pointer to it is copied into a 'ToolTipText structure Const cxPicture = 16 Const cyPicture = 15 'Default Property Values: 'Const m_def_ToolTipText = "" Const m_def_BackStyle = 0 Const m_def_BackColor = &H8000000F Const m_def_Enabled = True Const m_def_Style = 0 Const m_def_Value = False Const m_def_ButtonGroup = "" Const m_def_ButtonGroupDefault = False Const m_def_ButtonGroupDefault2 = False 'Property Variables: Dim m_DownPicture As Picture Dim m_FlatPicture As Picture Dim m_DisabledPicture As Picture 'Dim m_ToolTipText As String Dim m_BackStyle As Integer Dim m_BackColor As Long Dim m_BackColorUse As Long Dim m_Picture As Picture Dim m_Enabled As Boolean Dim m_Style As Integer Dim m_Value As Boolean Dim m_ButtonGroupDefault As Boolean Dim m_ButtonGroupDefault2 As Boolean Dim m_ButtonGroup As String Public Enum PopupButtonStyle [Toolbar Button] = 0 [Flat Button] = 1 [Separator] = 2 [Toolbar Handle] = 3 [Up-Down Button] = 4 [Standard Button] = 5 End Enum Public Enum PopupButtonBackStyle Transparent Opaque End Enum 'Event Declarations: Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) Event Click() Private PEffect As PaintEffects Private Sub UserControl_Initialize() Inside = False Set PEffect = New PaintEffects UpDownButtonFace = PEffect.AverageColors(GetSysColor(COLOR_BTNFACE), GetSysColor(COLOR_BTNHIGHLIGHT)) InitializeUpDownDither End Sub Private Sub PaintUpDownDither(x As Single, y As Single, Width As Single, Height As Single) Dim ret As Long Dim MyRect As RECT 'draw on the form with that brush MyRect.Left = x MyRect.Top = y MyRect.Right = x + Width MyRect.Bottom = y + Height ret = FillRect(UserControl.hDC, MyRect, hUpDownDitherBrush) End Sub Private Sub InitializeUpDownDither() Dim i As Long, j As Long '---one-time setup: put this in it's own routine------ 'set (invisible) picturebox properties for creating a brush ' UserControl.ScaleMode = vbPixels ' UserControl.AutoRedraw = True 'draw the dither in it For i = 0 To UserControl.ScaleWidth - 1 For j = 0 To UserControl.ScaleHeight - 1 If (i + j) Mod 2 Then UserControl.PSet (i, j), vb3DHighlight Else UserControl.PSet (i, j), vbButtonFace End If Next j Next i '---end of one-time setup------ 'create the brush from it hUpDownDitherBrush = CreatePatternBrush(UserControl.Image.handle) End Sub Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) IsDown = True UserControl_MouseMove Button, Shift, x, y UserControl_Paint End Sub Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) Dim NeedCapture As Boolean On Error GoTo UserCtlMouseMoveErr Select Case m_Style Case [Toolbar Button], [Flat Button], [Up-Down Button], [Standard Button] ' Is the mouse inside the control's client area? Inside = (x > 0) And (y > 0) And (x < ScaleWidth) And (y < ScaleHeight) If Inside And m_Enabled Then If PaintedUp Or (Not ButtonVisible) Then ButtonVisible = True Cls UserControl_Paint End If If Not ((m_Style = [Up-Down Button]) And m_Value) Then DrawShadowBox 0, 0, ScaleWidth, ScaleHeight, IsDown, ((m_Style = [Flat Button]) Or (m_Style = [Standard Button])) Else DrawShadowBox 0, 0, ScaleWidth, ScaleHeight, True, ((m_Style = [Flat Button]) Or (m_Style = [Standard Button])) End If Else If IsDown And m_Enabled Then If Not (PaintedUp And ButtonVisible) Then ButtonVisible = True Cls UserControl_Paint End If DrawShadowBox 0, 0, ScaleWidth, ScaleHeight, False, ((m_Style = [Flat Button]) Or (m_Style = [Standard Button])) Else If ButtonVisible Then ButtonVisible = False Cls UserControl_Paint End If If Not (((m_Style = [Up-Down Button]) And m_Value) Or (m_Style = [Standard Button])) Then Line (0, 0)-(ScaleWidth, ScaleHeight), m_BackColorUse, B Line (1, 1)-(ScaleWidth - 1, ScaleHeight - 1), m_BackColorUse, B End If End If End If NeedCapture = (IsDown Or (Inside And (Not IsUp))) And m_Enabled If IsUp Then IsUp = False ' Set or release mouse capture if necessary If NeedCapture And (HaveCapture = False) Then SetCapture hwnd HaveCapture = True ElseIf (NeedCapture = False) And HaveCapture Then ReleaseCapture HaveCapture = False End If End Select RaiseEvent MouseMove(Button, Shift, x, y) Exit Sub UserCtlMouseMoveErr: Exit Sub End Sub Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) If IsDown And m_Enabled And Inside Then If m_Style = [Up-Down Button] Then m_Value = Not m_Value CheckButtonGroup End If RaiseEvent Click End If IsDown = False IsUp = True On Error Resume Next UserControl_MouseMove Button, Shift, -1, -1 'X, Y UserControl_Paint End Sub Private Sub UserControl_Paint() On Error Resume Next Select Case m_Style Case [Toolbar Button], [Flat Button], [Up-Down Button], [Standard Button] PaintedUp = Not (IsDown And Inside) If ButtonVisible Then If (m_Style = [Flat Button]) Or (m_Style = [Standard Button]) Then If PaintedUp Then Line (1, 1)-(ScaleWidth - 2, ScaleHeight - 2), vbButtonFace, BF Else Line (2, 2)-(ScaleWidth - 2, ScaleHeight - 2), vbButtonFace, BF End If Else Line (1, 1)-(ScaleWidth - 2, ScaleHeight - 2), vbButtonFace, BF End If Else If (m_Style = [Up-Down Button]) Then If m_Value Then If Inside Then Line (1, 1)-(ScaleWidth - 2, ScaleHeight - 2), vbButtonFace, BF Else 'use this to dither: PaintUpDownDither 1, 1, ScaleWidth - 2, ScaleHeight - 2 'use this to average: 'Line (1, 1)-(ScaleWidth - 1, ScaleHeight - 1), UpDownButtonFace, BF End If DrawShadowBox 0, 0, ScaleWidth, ScaleHeight, True, False Else Line (0, 0)-(ScaleWidth, ScaleHeight), m_BackColorUse, BF End If ElseIf (m_Style = [Standard Button]) Then If PaintedUp Then Line (1, 1)-(ScaleWidth - 2, ScaleHeight - 2), vbButtonFace, BF Else Line (2, 2)-(ScaleWidth - 1, ScaleHeight - 1), vbButtonFace, BF End If DrawShadowBox 0, 0, ScaleWidth, ScaleHeight, False, True Else Line (0, 0)-(ScaleWidth, ScaleHeight), m_BackColorUse, BF End If End If If IsAPicture(m_Picture) Then Dim xPixels As Long, yPixels As Long If m_Enabled Then Dim picUse As StdPicture If (IsDown Or ((m_Style = [Up-Down Button]) And m_Value)) And IsAPicture(m_DownPicture) Then Set picUse = m_DownPicture ElseIf Inside Or Not IsAPicture(m_FlatPicture) Then Set picUse = m_Picture Else Set picUse = m_FlatPicture End If xPixels = CLng(UserControl.ScaleX(picUse.Width, vbHimetric, vbPixels)) yPixels = CLng(UserControl.ScaleY(picUse.Height, vbHimetric, vbPixels)) PEffect.PaintTransCornerStdPic UserControl.hDC, (ScaleWidth - xPixels) / 2 + IIf(Not PaintedUp, 1, 0), (ScaleHeight - yPixels) / 2 + IIf(Not PaintedUp, 1, 0), xPixels, yPixels, picUse, 0, 0 ' PEffect.PaintGreyScaleCornerStdPic UserControl.hDC, (ScaleWidth - xPixels) / 2 + IIf(Not PaintedUp, 1, 0), (ScaleHeight - yPixels) / 2 + IIf(Not PaintedUp, 1, 0), xPixels, yPixels, picUse, 0, 0 Else PaintedUp = True If IsAPicture(m_DisabledPicture) Then xPixels = CLng(UserControl.ScaleX(m_DisabledPicture.Width, vbHimetric, vbPixels)) yPixels = CLng(UserControl.ScaleY(m_DisabledPicture.Height, vbHimetric, vbPixels)) PEffect.PaintTransCornerStdPic UserControl.hDC, (ScaleWidth - xPixels) / 2 + IIf(Not PaintedUp, 1, 0), (ScaleHeight - yPixels) / 2 + IIf(Not PaintedUp, 1, 0), xPixels, yPixels, m_DisabledPicture, 0, 0 Else xPixels = CLng(UserControl.ScaleX(m_Picture.Width, vbHimetric, vbPixels)) yPixels = CLng(UserControl.ScaleY(m_Picture.Height, vbHimetric, vbPixels)) PEffect.PaintDisabledCornerStdPic UserControl.hDC, (ScaleWidth - xPixels) / 2 + IIf(Not PaintedUp, 1, 0), (ScaleHeight - yPixels) / 2 + IIf(Not PaintedUp, 1, 0), xPixels, yPixels, m_Picture, 0, 0 End If End If End If Case [Separator] Line (0, 0)-(ScaleWidth, ScaleHeight), m_BackColorUse, BF DrawVLine ScaleWidth \ 2 - 1, 0, 2, ScaleHeight Case [Toolbar Handle] Line (0, 0)-(ScaleWidth, ScaleHeight), m_BackColorUse, BF DrawRaisedVLine ScaleWidth \ 2 - 4, 0, 3, ScaleHeight DrawRaisedVLine ScaleWidth \ 2, 0, 3, ScaleHeight End Select End Sub Private Function IsAPicture(pic As StdPicture) As Boolean If (pic Is Nothing) Then IsAPicture = False Else IsAPicture = (pic <> 0) End If End Function Private Sub DrawShadowBox(ByVal x As Single, ByVal y As Single, ByVal cx As Single, ByVal cy As Single, ByVal Pressed As Boolean, ByVal DKShadow As Boolean) If DKShadow Then If Pressed Then Line (x, y)-(x + cx - 1, y), vb3DDKShadow Line (x, y)-(x, y + cy - 1), vb3DDKShadow Line (x + 1, y + 1)-(x + cx - 2, y + 1), vbButtonShadow Line (x + 1, y + 1)-(x + 1, y + cy - 2), vbButtonShadow Line (x + cx - 1, y)-(x + cx - 1, y + cy), vb3DHighlight Line (x, y + cy - 1)-(x + cx, y + cy - 1), vb3DHighlight Else Line (x, y)-(x + cx - 1, y), vb3DHighlight Line (x, y)-(x, y + cy - 1), vb3DHighlight Line (x + cx - 2, y + 1)-(x + cx - 2, y + cy - 1), vbButtonShadow Line (x + 1, y + cy - 2)-(x + cx - 1, y + cy - 2), vbButtonShadow Line (x + cx - 1, y)-(x + cx - 1, y + cy), vb3DDKShadow Line (x, y + cy - 1)-(x + cx, y + cy - 1), vb3DDKShadow End If Else Dim Color1 As Long Dim Color2 As Long If Pressed Then Color1 = vbButtonShadow Color2 = vb3DHighlight Else Color1 = vb3DHighlight Color2 = vbButtonShadow End If Line (x, y)-(x + cx - 1, y), Color1 Line (x, y)-(x, y + cy - 1), Color1 Line (x + cx - 1, y)-(x + cx - 1, y + cy), Color2 Line (x, y + cy - 1)-(x + cx, y + cy - 1), Color2 End If End Sub Private Sub DrawVLine(ByVal x As Single, ByVal y As Single, ByVal cx As Single, ByVal cy As Single) Line (x + 1, y)-(x + 1, y + cy), vb3DHighlight Line (x, y)-(x, y + cy), vbButtonShadow End Sub Private Sub DrawRaisedVLine(ByVal x As Single, ByVal y As Single, ByVal cx As Single, ByVal cy As Single) Line (x, y)-(x, y + cy), vb3DHighlight Line (x + 1, y)-(x + 1, y + cy), vb3DHighlight Line (x + 2, y)-(x + 2, y + cy), vb3DHighlight Line (x, y + 1)-(x, y + cy), vbButtonShadow Line (x + 1, y + 1)-(x + 1, y + cy), vbButtonShadow Line (x + 2, y + 1)-(x + 2, y + cy), vbButtonShadow Line (x, y)-(x, y + cy - 1), vb3DHighlight Line (x + 1, y + 1)-(x + 1, y + cy - 1), vbButtonFace End Sub 'Load property values from storage Private Sub UserControl_ReadProperties(PropBag As PropertyBag) On Error Resume Next Set m_Picture = PropBag.ReadProperty("Picture", Nothing) m_Enabled = PropBag.ReadProperty("Enabled", m_def_Enabled) m_Style = PropBag.ReadProperty("Style", m_def_Style) m_Value = PropBag.ReadProperty("Value", m_def_Value) m_ButtonGroup = PropBag.ReadProperty("ButtonGroup", m_def_ButtonGroup) m_ButtonGroupDefault = PropBag.ReadProperty("ButtonGroupDefault", m_def_ButtonGroupDefault) m_ButtonGroupDefault2 = PropBag.ReadProperty("ButtonGroupDefault2", m_def_ButtonGroupDefault2) m_BackStyle = PropBag.ReadProperty("BackStyle", m_def_BackStyle) m_BackColor = PropBag.ReadProperty("BackColor", UserControl.Extender.Container.BackColor) ' m_BackColor = PropBag.ReadProperty("BackColor", m_def_BackColor) SetBackColor ' m_ToolTipText = PropBag.ReadProperty("ToolTipText", m_def_ToolTipText) ' ToolTipText = m_ToolTipText Set m_DownPicture = PropBag.ReadProperty("DownPicture", Nothing) Set m_FlatPicture = PropBag.ReadProperty("FlatPicture", Nothing) Set m_DisabledPicture = PropBag.ReadProperty("DisabledPicture", Nothing) InstanciateToolTipsWindow End Sub Private Sub UserControl_Resize() UserControl_Paint End Sub Private Sub UserControl_Show() UserControl_Paint End Sub Private Sub UserControl_Terminate() Set PEffect = Nothing glToolsCount = glToolsCount - 1 UnSubClass If gbToolTipsInstanciated And glToolsCount = 0 Then DestroyWindow gHWndToolTip End If 'clean up Call DeleteObject(hUpDownDitherBrush) End Sub 'Write property values to storage Private Sub UserControl_WriteProperties(PropBag As PropertyBag) Call PropBag.WriteProperty("Picture", m_Picture, Nothing) Call PropBag.WriteProperty("Enabled", m_Enabled, m_def_Enabled) Call PropBag.WriteProperty("Style", m_Style, m_def_Style) Call PropBag.WriteProperty("Value", m_Value, m_def_Value) Call PropBag.WriteProperty("ButtonGroup", m_ButtonGroup, m_def_ButtonGroup) Call PropBag.WriteProperty("ButtonGroupDefault", m_ButtonGroupDefault, m_def_ButtonGroupDefault) Call PropBag.WriteProperty("ButtonGroupDefault2", m_ButtonGroupDefault2, m_def_ButtonGroupDefault2) Call PropBag.WriteProperty("BackStyle", m_BackStyle, m_def_BackStyle) Call PropBag.WriteProperty("BackColor", m_BackColor, UserControl.Extender.Container.BackColor) ' Call PropBag.WriteProperty("BackColor", m_BackColor, m_def_BackColor) ' Call PropBag.WriteProperty("ToolTipText", m_ToolTipText, m_def_ToolTipText) Call PropBag.WriteProperty("DownPicture", m_DownPicture, Nothing) Call PropBag.WriteProperty("FlatPicture", m_FlatPicture, Nothing) Call PropBag.WriteProperty("DisabledPicture", m_DisabledPicture, Nothing) End Sub Public Property Get Picture() As Picture Set Picture = m_Picture End Property Public Property Set Picture(ByVal New_Picture As Picture) Set m_Picture = New_Picture If m_Enabled Then Cls UserControl_Paint End If PropertyChanged "Picture" End Property Public Property Get DownPicture() As Picture Set DownPicture = m_DownPicture End Property Public Property Set DownPicture(ByVal New_DownPicture As Picture) Set m_DownPicture = New_DownPicture If m_Enabled Then Cls UserControl_Paint End If PropertyChanged "DownPicture" End Property Public Property Get FlatPicture() As Picture Set FlatPicture = m_FlatPicture End Property Public Property Set FlatPicture(ByVal New_FlatPicture As Picture) Set m_FlatPicture = New_FlatPicture If m_Enabled Then Cls UserControl_Paint End If PropertyChanged "FlatPicture" End Property Public Property Get DisabledPicture() As Picture Set DisabledPicture = m_DisabledPicture End Property Public Property Set DisabledPicture(ByVal New_DisabledPicture As Picture) Set m_DisabledPicture = New_DisabledPicture If Not m_Enabled Then Cls UserControl_Paint End If PropertyChanged "DisabledPicture" End Property 'Initialize Properties for User Control Private Sub UserControl_InitProperties() Set m_Picture = LoadPicture("") Set m_FlatPicture = LoadPicture("") Set m_DownPicture = LoadPicture("") Set m_DisabledPicture = LoadPicture("") m_Value = m_def_Value m_ButtonGroup = m_def_ButtonGroup m_ButtonGroupDefault = m_def_ButtonGroupDefault m_ButtonGroupDefault2 = m_def_ButtonGroupDefault2 m_Enabled = m_def_Enabled m_Style = m_def_Style m_BackStyle = m_def_BackStyle m_BackColor = UserControl.Extender.Container.BackColor ' m_BackColor = m_def_BackColor SetBackColor ' m_ToolTipText = m_def_ToolTipText ' UserControl.Extender.ToolTipText = m_ToolTipText UserControl_Resize End Sub Public Property Get ButtonGroup() As String ButtonGroup = m_ButtonGroup End Property Public Property Let ButtonGroup(ByVal New_ButtonGroup As String) If Not (m_ButtonGroup = New_ButtonGroup) Then m_ButtonGroup = New_ButtonGroup If m_Style = [Up-Down Button] Then CheckButtonGroup Cls UserControl_Paint End If End If PropertyChanged "ButtonGroup" End Property Public Property Get ButtonGroupDefault() As Boolean ButtonGroupDefault = m_ButtonGroupDefault End Property Public Property Let ButtonGroupDefault(ByVal New_ButtonGroupDefault As Boolean) 'The following line of code ensures that the integer 'value of the boolean parameter is either '0 or -1. It is known that Access 97 will 'set the boolean's value to 255 for true. 'In this case a P-Code compiled VB5 built 'OCX will return True for the expression '(Not [boolean variable that ='s 255]). This 'line ensures the reliability of boolean operations If CBool(New_ButtonGroupDefault) Then New_ButtonGroupDefault = True Else New_ButtonGroupDefault = False If Not (m_ButtonGroupDefault = New_ButtonGroupDefault) Then m_ButtonGroupDefault = New_ButtonGroupDefault If m_Style = [Up-Down Button] Then CheckButtonGroupDefault CheckButtonGroup Cls UserControl_Paint End If End If PropertyChanged "ButtonGroupDefault" End Property Private Sub CheckButtonGroupDefault() If (Len(m_ButtonGroup) > 0) Then If m_ButtonGroupDefault Then ' make all others in group not default Dim ctl As Control Dim i As Long For i = 0 To UserControl.ParentControls.Count - 1 If TypeOf UserControl.ParentControls(i) Is Control Then Set ctl = UserControl.ParentControls(i) If TypeOf ctl Is axDataButton Then If ctl.ButtonGroup = m_ButtonGroup Then If Not ((ctl Is UserControl.Extender) Or (ctl Is UserControl)) Then ctl.ButtonGroupDefault = False End If End If End If End If Next End If End If End Sub Public Property Get ButtonGroupDefault2() As Boolean ButtonGroupDefault2 = m_ButtonGroupDefault2 End Property Public Property Let ButtonGroupDefault2(ByVal New_ButtonGroupDefault2 As Boolean) 'The following line of code ensures that the integer 'value of the boolean parameter is either '0 or -1. It is known that Access 97 will 'set the boolean's value to 255 for true. 'In this case a P-Code compiled VB5 built 'OCX will return True for the expression '(Not [boolean variable that ='s 255]). This 'line ensures the reliability of boolean operations If CBool(New_ButtonGroupDefault2) Then New_ButtonGroupDefault2 = True Else New_ButtonGroupDefault2 = False If Not (m_ButtonGroupDefault2 = New_ButtonGroupDefault2) Then m_ButtonGroupDefault2 = New_ButtonGroupDefault2 If m_Style = [Up-Down Button] Then CheckButtonGroupDefault2 CheckButtonGroup Cls UserControl_Paint End If End If PropertyChanged "ButtonGroupDefault2" End Property Private Sub CheckButtonGroupDefault2() If (Len(m_ButtonGroup) > 0) Then If m_ButtonGroupDefault2 Then ' make all others in group not default Dim ctl As Control Dim i As Long For i = 0 To UserControl.ParentControls.Count - 1 If TypeOf UserControl.ParentControls(i) Is Control Then Set ctl = UserControl.ParentControls(i) If TypeOf ctl Is axDataButton Then If ctl.ButtonGroup = m_ButtonGroup Then If Not ((ctl Is UserControl.Extender) Or (ctl Is UserControl)) Then ctl.ButtonGroupDefault2 = False End If End If End If End If Next End If End If End Sub Private Sub CheckButtonGroup() If (Len(m_ButtonGroup) > 0) Then Dim ctl As Control Dim i As Long If m_Value Then ' clear all others in group For i = 0 To UserControl.ParentControls.Count - 1 If TypeOf UserControl.ParentControls(i) Is Control Then Set ctl = UserControl.ParentControls(i) If TypeOf ctl Is axDataButton Then If ctl.ButtonGroup = m_ButtonGroup Then If Not ((ctl Is UserControl.Extender) Or (ctl Is UserControl)) Then ctl.Value = False End If End If End If End If Next Else ' set group default if necessary Dim GroupValueSet As Boolean Dim ctlDefault As axDataButton Dim ctlDefault2 As axDataButton Set ctlDefault = Nothing Set ctlDefault2 = Nothing GroupValueSet = False For i = 0 To UserControl.ParentControls.Count - 1 If TypeOf UserControl.ParentControls(i) Is Control Then Set ctl = UserControl.ParentControls(i) If TypeOf ctl Is axDataButton Then If ctl.ButtonGroup = m_ButtonGroup Then ' If Not ((ctl Is UserControl.Extender) Or (ctl Is UserControl)) Then If ctl.Value Then GroupValueSet = True Exit For ElseIf ctl.ButtonGroupDefault Then Set ctlDefault = ctl ElseIf ctl.ButtonGroupDefault2 Then Set ctlDefault2 = ctl End If ' End If End If End If End If Next If Not (GroupValueSet Or (ctlDefault Is Nothing)) Then If (Not m_ButtonGroupDefault) Or (ctlDefault2 Is Nothing) Then ctlDefault.Value = True Else ctlDefault2.Value = True End If End If End If End If End Sub Public Property Get Value() As Boolean Value = m_Value End Property Public Property Let Value(ByVal New_Value As Boolean) 'The following line of code ensures that the integer 'value of the boolean parameter is either '0 or -1. It is known that Access 97 will 'set the boolean's value to 255 for true. 'In this case a P-Code compiled VB5 built 'OCX will return True for the expression '(Not [boolean variable that ='s 255]). This 'line ensures the reliability of boolean operations If CBool(New_Value) Then New_Value = True Else New_Value = False If Not (m_Value = New_Value) Then m_Value = New_Value If m_Style = [Up-Down Button] Then CheckButtonGroup Cls UserControl_Paint End If End If PropertyChanged "Value" End Property Public Property Get Enabled() As Boolean Enabled = m_Enabled End Property Public Property Let Enabled(ByVal New_Enabled As Boolean) 'The following line of code ensures that the integer 'value of the boolean parameter is either '0 or -1. It is known that Access 97 will 'set the boolean's value to 255 for true. 'In this case a P-Code compiled VB5 built 'OCX will return True for the expression '(Not [boolean variable that ='s 255]). This 'line ensures the reliability of boolean operations If CBool(New_Enabled) Then New_Enabled = True Else New_Enabled = False If Not (m_Enabled = New_Enabled) Then m_Enabled = New_Enabled Inside = False Cls UserControl_Paint End If PropertyChanged "Enabled" End Property Public Property Get Style() As PopupButtonStyle Style = m_Style End Property Public Property Let Style(ByVal New_Style As PopupButtonStyle) If Not (m_Style = New_Style) Then m_Style = New_Style Cls UserControl_Paint End If PropertyChanged "Style" End Property Public Property Get BackStyle() As PopupButtonBackStyle BackStyle = m_BackStyle End Property Public Property Let BackStyle(ByVal New_BackStyle As PopupButtonBackStyle) If Not (m_BackStyle = New_BackStyle) Then m_BackStyle = New_BackStyle SetBackColor Cls UserControl_Paint End If PropertyChanged "BackStyle" End Property Public Property Get BackColor() As OLE_COLOR BackColor = m_BackColor End Property Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR) If Not (m_BackColor = New_BackColor) Then m_BackColor = New_BackColor SetBackColor Cls UserControl_Paint End If PropertyChanged "BackColor" End Property Private Sub SetBackColor() If (m_BackStyle = Opaque) Then m_BackColorUse = m_BackColor Else m_BackColorUse = UserControl.Extender.Container.BackColor End If End Sub 'Public Property Get ToolTipText() As String ' ToolTipText = m_ToolTipText 'End Property 'Public Property Let ToolTipText(ByVal New_ToolTipText As String) ' MsgBox "let : " & New_ToolTipText ' m_ToolTipText = New_ToolTipText '' UserControl.Extender.ToolTipText = m_ToolTipText ' PropertyChanged "ToolTipText" 'End Property '************************* 'Private Procedures '************************* 'Private Sub MakeClick() ' '------------------------------------------------------------------------- ' 'Purpose: Raise a Click event to container, play sound ' '------------------------------------------------------------------------- ' '----------------------------------------- ' '- Added for sound support ' '----------------------------------------- ' If m_bPlaySounds Then PlaySound EVENT_MENU_COMMAND, 0, SND_SYNC ' '----------------------------------------- ' RaiseEvent Click 'End Sub 'Private Sub MouseOver() ' '------------------------------------------------------------------------- ' 'Purpose: Call whenever the mouse is over the button and ' ' button needs raised appearance and capture set ' '------------------------------------------------------------------------- ' If miCurrentState <> giRAISED Then DrawButtonState giRAISED ' If Not mbMouseOver Then ' Capture True ' mbMouseOver = True ' '----------------------------------------- ' '- Added for sound support ' '----------------------------------------- ' If Not mbEnterOnce Then ' RaiseEvent PopUp ' If m_bPlaySounds Then PlaySound EVENT_MENU_POPUP, 0, SND_SYNC ' mbEnterOnce = True ' End If ' '----------------------------------------- ' End If 'End Sub 'Private Sub Flatten() ' '------------------------------------------------------------------------- ' 'Purpose: Call whenever the mouse is off the control ' ' and capture needs released and button needs ' ' flattened appearance ' '------------------------------------------------------------------------- ' If mbMouseOver Then Capture False ' mbMouseOver = False ' If (Not mbGotFocus) And miCurrentState <> giFLATTENED Then DrawButtonState giFLATTENED ' '----------------------------------------- ' '- Added for sound support ' '----------------------------------------- ' ' PlaySound EVENT_MENU_POPUP, 0, SND_SYNC ' mbEnterOnce = False ' '----------------------------------------- 'End Sub 'Private Sub UserControl_AsyncReadComplete(AsyncProp As AsyncProperty) ' On Error GoTo ErrorHandler ' If (AsyncProp.PropertyName = msPICTURE_NAME) Then ' Picture download is complete ' mbClearPictureOnly = True ' Set Picture = AsyncProp.Value ' Store picture data to property... ' End If 'ErrorHandler: ' mbClearPictureOnly = False 'End Sub Private Sub AddTool(hwnd As Long) '------------------------------------------------------------------------- 'Purpose: Add a tool to the ToolTips object 'In: [hWnd] ' hWnd of Tool being added '------------------------------------------------------------------------- Dim ti As TOOLINFO With ti .cbSize = Len(ti) .uId = hwnd .hwnd = hwnd .hinst = App.hInstance .uFlags = TTF_IDISHWND .lpszText = LPSTR_TEXTCALLBACK End With SendMessage gHWndToolTip, TTM_ADDTOOL, 0, ti SendMessage gHWndToolTip, TTM_ACTIVATE, 1, ByVal hwnd Exit Sub End Sub Private Sub InstanciateToolTipsWindow() '------------------------------------------------------------------------- 'Purpose: Instanciate needed collections. ' Create ToolTips Class window '------------------------------------------------------------------------- If Not (TypeOf UserControl.Extender.Parent Is axPicker) Then Exit Sub glToolsCount = glToolsCount + 1 If UserControl.Extender.Parent.Ambient.UserMode Then If Not gbToolTipsInstanciated Then gbToolTipsInstanciated = True InitCommonControls gHWndToolTip = CreateWindowEX(WS_EX_TOPMOST, TOOLTIPS_CLASS, vbNullString, 0, _ CW_USEDEFAULT, CW_USEDEFAULT, _ CW_USEDEFAULT, CW_USEDEFAULT, _ 0, 0, _ App.hInstance, _ ByVal 0) SendMessage gHWndToolTip, TTM_ACTIVATE, 1, ByVal 0 #If DEBUGSUBCLASS Then If goWindowProcHookCreator Is Nothing Then Set goWindowProcHookCreator = CreateObject("DbgWindowProc.WindowProcHookCreator") #End If End If 'Sub class this code module to receive 'window messages for the Usercontrol SubClass UserControl.hwnd 'Add Register Usercontrol with ToolTip window AddTool UserControl.hwnd End If End Sub Private Sub SubClass(hwnd) '------------------------------------------------------------------------- 'Purpose: Subclass control so that the ToolTip Need text message can be ' handled. Store handle of class as UserData of control window '------------------------------------------------------------------------- Dim lresult As Long UnSubClass #If DEBUGSUBCLASS Then 'If in debug, SubClass window using address of WindowProcHook 'Let WindowProcHook CallWindowProc at address of my function 'if in run mode but call the previous address if in break mode 'this prevents crashes in break mode Set moProcHook = goWindowProcHookCreator.CreateWindowProcHook With moProcHook .SetMainProc AddressOf SubWndProc mWndProcNext = SetWindowLong(hwnd, GWL_WNDPROC, CLng(.ProcAddress)) .SetDebugProc mWndProcNext End With #Else mWndProcNext = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf SubWndProc) #End If If mWndProcNext Then mHWndSubClassed = hwnd lresult = SetWindowLong(hwnd, GWL_USERDATA, ObjPtr(Me)) End If End Sub Private Sub UnSubClass() '------------------------------------------------------------------------- 'Purpose: Unsubclass control '------------------------------------------------------------------------- If mWndProcNext Then SetWindowLong mHWndSubClassed, GWL_WNDPROC, mWndProcNext mWndProcNext = 0 #If DEBUGSUBCLASS Then Set moProcHook = Nothing #End If End If End Sub '************************* 'Friend Methods '************************* Friend Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long '------------------------------------------------------------------------- 'Purpose: Handles window messages specific to subclassed window associated ' with this object. Is called by SubWndProc in standard module. ' Relays all mouse messages to ToolTip window, and returns a value ' for ToolTip NeedText message. '------------------------------------------------------------------------- Dim msgStruct As MSG Dim hdr As NMHDR Dim ttt As ToolTipText On Error GoTo WindowProc_Error Select Case uMsg Case WM_MOUSEMOVE, WM_LBUTTONDOWN, WM_LBUTTONUP, WM_RBUTTONDOWN, WM_RBUTTONUP, WM_MBUTTONDOWN, WM_MBUTTONUP With msgStruct .lParam = lParam .wParam = wParam .message = uMsg .hwnd = hwnd End With If m_Enabled Then SendMessage gHWndToolTip, TTM_RELAYEVENT, 0, msgStruct End If Case WM_NOTIFY CopyMemory hdr, ByVal lParam, Len(hdr) If hdr.code = TTN_NEEDTEXT And hdr.hwndFrom = gHWndToolTip Then 'Get the tooltip text from the UserControl class object 'If the host for this control provides a ToolTipText property 'on the extender object (as in VB5). The ToolTipText property 'declares will not be hit. Therefore, the user's ToolTipText 'may be found either in the Extender.ToolTipText property or 'in my own member variable m_sToolTipText 'Error may occur if ToolTipText property is not available 'On Error Resume Next ' If mbToolTipNotInExtender Then ' msToolTipBuffer = StrConv(m_sToolTipText, vbFromUnicode) ' Else ' msToolTipBuffer = StrConv(UserControl.Extender.ToolTipText, vbFromUnicode) ' End If ' msToolTipBuffer = "safsaf" msToolTipBuffer = StrConv(UserControl.Extender.ToolTipText, vbFromUnicode) ' Debug.Print " > " & msToolTipBuffer & " : " & m_ToolTipText & " : " & UserControl.Extender.ToolTipText If Err.Number = 0 Then CopyMemory ttt, ByVal lParam, Len(ttt) ttt.lpszText = StrPtr(msToolTipBuffer) CopyMemory ByVal lParam, ttt, Len(ttt) End If End If Case WM_CANCELMODE 'A window has been put over this one 'flatten the button ' Flatten mbGotFocus = False mbLeftMouseDown = False mbLeftWasDown = False mbMouseDownFired = False End Select WindowProc_Resume: WindowProc = CallWindowProc(mWndProcNext, hwnd, uMsg, wParam, ByVal lParam) Exit Function WindowProc_Error: Resume WindowProc_Resume End Function 
(.txt)